Sub 两表找不同和相同()
'快速匹配两表中相同的数据，不同的的数据
'分别命名3个表 表1 表2 匹配结果
    Dim d As Object
    Dim aData1, aData2, aRes, aKeys
    Dim strKey As String, strMsg As String
    Dim i As Long, k As Long
    Dim intSame As Long, intShtA As Long, intShtB As Long
    Set d = CreateObject("scripting.dictionary")
    With Worksheets("表1")
        aData1 = .Range("a1:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
    End With
    With Worksheets("表2")
        aData2 = .Range("a1:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
    End With
    For i = 2 To UBound(aData1)
        strKey = aData1(i, 1)
        d(strKey) = "表1"
    Next
    ReDim aRes(1 To UBound(aData1) + UBound(aData2), 1 To 3)
    For i = 2 To UBound(aData2)
        strKey = aData2(i, 1)
        If d.exists(strKey) Then
            If d(strKey) = "表1" Then
                intSame = intSame + 1
                aRes(intSame, 1) = strKey
                d(strKey) = "相同"
            End If
        Else
            intShtB = intShtB + 1
            aRes(intShtB, 3) = strKey
            d(strKey) = "表2"
        End If
    Next
    aKeys = d.keys
    For i = 0 To UBound(aKeys)
        strKey = aKeys(i)
        If d(strKey) = "表1" Then
            intShtA = intShtA + 1
            aRes(intShtA, 2) = strKey
        End If
    Next
    If k < intSame Then k = intSame
    If k < intShtA Then k = intShtA
    If k < intShtB Then k = intShtB
    Worksheets("匹配结果").Select
    Range("a:e").ClearContents
    Range("a1").Resize(UBound(aData1), 1) = aData1
    Range("b1").Resize(UBound(aData2), 1) = aData2
    Range("a1:e1") = Array("表1数据", "表2数据", "相同项", "表1独有", "表2独有")
    Range("c2").Resize(k, UBound(aRes, 2)) = aRes
    strMsg = "两表相同项：" & intSame & vbCrLf _
            & "表1独有项：" & intShtA & vbCrLf _
            & "表2独有项：" & intShtB
    MsgBox strMsg, , "wps888.cn"
    Set d = Nothing
End Sub